home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / xlib.lha / xlib / cdecl / typedef.scm < prev   
Text File  |  1990-05-31  |  17KB  |  511 lines
  1. ;;; C Declaration Language
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. ;;; This module compile type declarations.
  42. ;;;
  43. ;;; Data types are defined by this type of expression.  Initially, we'll
  44. ;;; try to accept as few forms as possible by doing a little "hand casting".
  45. ;;; The legal forms are:
  46. ;;;
  47. ;;;    (typedef <type> <identifier>)
  48. ;;;
  49. ;;; where:
  50. ;;;
  51. ;;;    <type> ::= (<stype> *)
  52. ;;;           (<stype> *proc)
  53. ;;;
  54. ;;;    <atype> ::= (<stype> integer)
  55. ;;;            <struct-or-union-specifier>
  56. ;;;
  57. ;;;    <stype> ::= char
  58. ;;;            shortint
  59. ;;;            shortunsigned
  60. ;;;            int
  61. ;;;            unsigned
  62. ;;;            float
  63. ;;;            double
  64. ;;;            <type-def-name>
  65. ;;;
  66. ;;;    <type-def-name> ::= <identifier> denoting another type
  67. ;;;
  68. ;;;    <struct-or-union-specifier> ::=    ( struct [<struct-decl> ...] )
  69. ;;;                    ( union  [<struct-decl> ...] )
  70. ;;;
  71. ;;;    <struct-decl> ::= ( <atype> <identifier> )
  72.  
  73. (module typedef)
  74.  
  75. ;;; Type definition expressions from the input file are parsed by the
  76. ;;; following expression.  It will return the type name on success, or
  77. ;;; call error on an error.
  78.  
  79. (define (INPUT-TYPEDEF exp)
  80.     (if (and (= (length exp) 3) (eq? (car exp) 'typedef) (symbol? (caddr exp)))
  81.     (let ((id (caddr exp))
  82.           (parse (parse-type (cadr exp))))
  83.          (putprop id 'base-type #f)
  84.          (putprop id 'type parse)
  85.          (if (and (pair? parse) (symbol? (car parse))
  86.               (eq? (cadr parse) '*))
  87.          (putprop (car parse) 'pointed-to-by id))
  88.          id)
  89.     (error "Illegal syntax: ~s" exp)))
  90.  
  91. ;;; Type declarations are parsed by the following function.  It will return
  92. ;;; the type definition, or call error on an error.  Some of these type
  93. ;;; transformations may be MACHINE DEPENDENT.
  94.  
  95. (define (PARSE-TYPE type)
  96.     (if (pair? type)
  97.     (cond ((memq (car type) '(struct union))
  98.            (struct-or-union type))
  99.           ((equal? (cdr type) '(*))
  100.            (list (parse-stype (car type)) '*))
  101.           ((equal? (cdr type) '(*proc))
  102.            (list (parse-stype (car type)) '*proc))
  103.           (else (parse-atype type)))
  104.     (parse-stype type)))
  105.  
  106. (define (PARSE-ATYPE type)
  107.     (if (pair? type)
  108.     (cond ((memq (car type) '(struct union))
  109.            (struct-or-union type))
  110.           ((and (= (length type) 2)
  111.            (integer? (cadr type)) (>= (cadr type) 0))
  112.            (list (parse-stype (car type)) (cadr type)))
  113.           (else (error "Argument is not a legal type: ~s"
  114.                type)))
  115.     (parse-stype type)))
  116.  
  117. (define (PARSE-STYPE type)
  118.     (if (symbol? type)
  119.     type
  120.     (error "Argument is not a legal type: ~s" type)))
  121.  
  122. ;;; Structs and unions are handled by the following functions.
  123.  
  124. (define (STRUCT-OR-UNION exp)
  125.     (list (case (car exp)
  126.         ((struct) 'struct)
  127.         ((union) 'union)
  128.         (else (error "Illegal syntax: ~s" exp)))
  129.       (map (lambda (slot)
  130.                (if (and (= (length slot) 2) (symbol? (cadr slot)))
  131.                (list (parse-slot-type (car slot)) (cadr slot))
  132.                    (error
  133.                   "Argument is not a legal slot: ~s" slot)))
  134.            (cdr exp))))
  135.  
  136. ;;; When the type specifier for a slot is parsed, it may be contain an
  137. ;;; array or structure definition, or a symbol.  Arrays and structures
  138. ;;; defined here must have a dummy type assigned to them.
  139.  
  140. (define PARSE-SLOT-TYPE
  141.     (let ((uid 1))
  142.      (lambda (type)
  143.          (let ((parse (parse-atype type)))
  144.               (if (symbol? parse)
  145.               parse
  146.               (let ((symbol
  147.                  (string->symbol (format "*TYPE~s" uid))))
  148.                    (set! uid (+ uid 1))
  149.                    (putprop symbol 'base-type #f)
  150.                    (putprop symbol 'type parse)
  151.                    symbol))))))
  152.  
  153. ;;; The base types recognized by the type system are known to C and have
  154. ;;; known bytes sizes WHICH MAY BE MACHINE DEPENDENT.
  155.  
  156. (define (initialize-types)
  157. (for-each
  158.     (lambda (x)
  159.         (let ((type (list-ref x 0))
  160.           (size (list-ref x 1))
  161.           (to-ref (list-ref x 2))
  162.           (to-set! (list-ref x 3)))
  163.          (putprop type 'type #t)
  164.          (putprop type 'base-type type)
  165.          (putprop type 'size size)
  166.          (putprop type 'to-get to-ref)
  167.          (putprop type 'to-set! to-set!)))
  168.  
  169.     ;  C type          size      to access        to set!
  170.  
  171.     '((char              1     mref-8-u        set-mref-8-u!)
  172.       (shortint          2     mref-16-s        set-mref-16-s!)
  173.       (shortunsigned    2     mref-16-u             set-mref-16-u!)
  174.       (int        4     mref-integer            set-mref-integer!)
  175.       (unsigned        4    mref-integer        set-mref-integer!)
  176.       (pointer        4    mref-pointer        set-mref-pointer!)
  177.       (procedure    4    mref-pointer        set-mref-pointer!))))
  178. ;      (float        4    c-float-ref        c-float-set!)
  179. ;      (double        8    c-double-ref        c-double-set!)))
  180.  
  181. ;;; Every type symbol can be resolved into a base type symbol by the following
  182. ;;; function.  Once a base type has been computed, it is saved on the
  183. ;;; property list.
  184.  
  185. (define (BASE-TYPE start-type)
  186.     (or (getprop start-type 'base-type)
  187.     (let loop ((type start-type) (count 20))
  188.          (let ((typeinfo (getprop type 'type)))
  189.           (if (or (not typeinfo) (eq? count 0))
  190.               (error "BASE TYPE cannot be resolved: ~s"
  191.                  start-type))
  192.           (if (symbol? typeinfo)
  193.               (loop typeinfo (- count 1))
  194.               (putprop start-type 'base-type type))))))
  195.  
  196. ;;; Basic information about a type is returned by:
  197.  
  198. (define (ISA-UNION? type)
  199.     (let ((typeinfo (getprop (base-type type) 'type)))
  200.      (and (pair? typeinfo) (eq? (car typeinfo) 'union))))
  201.  
  202. (define (ISA-STRUCT? type)
  203.     (let ((typeinfo (getprop (base-type type) 'type)))
  204.      (and (pair? typeinfo) (eq? (car typeinfo) 'struct))))
  205.  
  206. (define (UORS-SLOTS type) (cadr (getprop (base-type type) 'type)))
  207.  
  208. (define (ISA-PROCP? type)
  209.     (let ((typeinfo (getprop (base-type type) 'type)))
  210.      (and (pair? typeinfo) (eq? (cadr typeinfo) '*proc))))
  211.  
  212. (define (PROCP-RETURNS type)
  213.     (base-type (car (getprop (base-type type) 'type))))
  214.  
  215. (define (ISA-POINTER? type)
  216.     (let ((typeinfo (getprop (base-type type) 'type)))
  217.      (and (pair? typeinfo) (eq? (cadr typeinfo) '*))))
  218.  
  219. (define (POINTER-TO type)
  220.     (base-type (car (getprop (base-type type) 'type))))
  221.  
  222. (define (ISA-ARRAY? type)
  223.     (let ((typeinfo (getprop (base-type type) 'type)))
  224.      (and (pair? typeinfo) (number? (cadr typeinfo)))))
  225.  
  226. (define (ARRAY-SIZE type) (cadr (getprop (base-type type) 'type)))
  227.  
  228. (define (ARRAY-TYPE type) (base-type (car (getprop (base-type type) 'type))))
  229.  
  230. (define (POINTED-TO-BY type)
  231.     (base-type (getprop (base-type type) 'pointed-to-by)))
  232.  
  233. ;;; Given this information, we can now compute sizes of things.  There may
  234. ;;; be future MACHINE DEPENDENT problems here as we aren't worrying about
  235. ;;; alignment.
  236.  
  237. (define (SIZE-OF type)
  238.     
  239.     (define (SIZE-OF-SU slots func)
  240.         (let ((size 0))
  241.          (for-each
  242.              (lambda (slot)
  243.                  (set! size (func size (size-of (car slot)))))
  244.              slots)
  245.          size))
  246.     
  247.     (cond ((getprop (base-type type) 'size))
  248.       ((isa-union? type) (size-of-su (uors-slots type) max))
  249.       ((isa-struct? type) (size-of-su (uors-slots type) +))
  250.       ((isa-procp? type) (size-of 'procedure))
  251.       ((isa-pointer? type) (size-of 'pointer))
  252.       ((isa-array? type) (* (array-size type) (size-of (array-type type))))
  253.       (else (error "Mystery type: ~s" type))))
  254.  
  255. ;;; A method for loading a type which takes an object, an offset, and an
  256. ;;; index (only for arrays) as it's arguments is returned by the following
  257. ;;; function.
  258.  
  259. (define (TO-GET-TYPE type)
  260.     (let ((base (base-type type)))
  261.      (cond ((getprop base 'to-get))
  262.            ((isa-array? base)
  263.         `(lambda (x y i)
  264.              (,(to-get-type (array-type base)) x
  265.               (fx+ y (fx* ,(size-of (array-type base)) i)))))
  266.            ((isa-pointer? base)
  267.         `(lambda (x y)
  268.              (cons ',base
  269.                    (,(to-get-type 'pointer) x y))))
  270.            ((isa-procp? base)
  271.         `(lambda (x y)
  272.              (cons ',base (,(to-get-type 'procedure) x y))))
  273.            (else #f))))
  274.  
  275. ;;; A method for storing a type which takes an object, an offset, an index
  276. ;;; (only for arrays), and a new value as it's arguments is returned by the
  277. ;;; following function.
  278.  
  279. (define (TO-SET!-TYPE type)
  280.       (let ((base (base-type type)))
  281.      (cond ((getprop base 'to-set!))
  282.            ((isa-array? base)
  283.         `(lambda (x y i z)
  284.              (,(to-set!-type (array-type base)) x
  285.               (fx+ y (fx* ,(size-of (array-type base)) i))
  286.               (,(to-check-type (array-type base)) z))))
  287.            ((isa-pointer? base)
  288.         `(lambda (x y z)
  289.              (,(to-set!-type 'pointer) x y
  290.               (,(to-check-type  base) z))))
  291.            ((isa-procp? base)
  292.         `(lambda (x y z)
  293.              (,(to-set!-type 'procedure) x y
  294.               (,(to-check-type base) z))))
  295.            (else #f))))
  296.  
  297. ;;; A method for checking a type and returning the "raw" value which takes an
  298. ;;; object as it's argument is returned by the following function.
  299.  
  300. (define (TO-CHECK-TYPE type)
  301.     (let ((base (base-type type)))
  302.      (if (or (isa-pointer? base) (isa-procp? base))
  303.          (uis "CHK-" base)
  304.          '(lambda (x) x))))
  305.  
  306. ;;; The symbol that is used as the type tag for objects is returned by the
  307. ;;; following procedure.  It returns #f when there is no type tag.
  308.  
  309. (define (TYPE-TAG type)
  310.     (let ((base (base-type type)))
  311.      (if (or (isa-pointer? base) (isa-procp? base))
  312.          base
  313.          #f)))
  314.  
  315. ;;; Converts a list of strings or symbols into an upper-case uninterned symbol.
  316.  
  317. (define (UIS . syms)
  318.     (string->uninterned-symbol
  319.     (list->string
  320.         (let loop ((syms syms))
  321.          (if syms
  322.              (append (map char-upcase
  323.                   (string->list
  324.                       (if (symbol? (car syms))
  325.                       (symbol->string (car syms))
  326.                       (car syms))))
  327.                  (loop (cdr syms)))
  328.              '())))))
  329.  
  330. ;;; Scheme code for type definitions is emitted by the following procedure
  331. ;;; which is called with a list of all type names, a list of definition
  332. ;;; only types, and a list of read-only types, and the filename/modulename
  333. ;;; prefix.
  334.  
  335. (define (EMIT-TYPEDEFS types define-only read-only type-file-root)
  336.     (let ((check (open-output-file (string-append type-file-root ".t")))
  337.       (type-module (uis type-file-root)))
  338.      
  339.      (define (EMIT-TYPE type read-only)
  340.          (cond ((isa-pointer? type)
  341.             (emit-chk-procs type def-print)
  342.             (cond ((or (isa-union? (pointer-to type))
  343.                    (isa-struct? (pointer-to type)))
  344.                    (emit-struct-procs type read-only
  345.                    type-file-root))
  346.                   ((isa-array? (pointer-to type))
  347.                    (emit-array-procs type read-only def-print))))
  348.                ((isa-procp? type)
  349.             (emit-chk-procs type def-print))))
  350.      
  351.      (define (DEF-PRINT exp)
  352.          (pp exp check)
  353.          (newline check))
  354.      
  355.      (format check "(herald ~a (env tsys (xlib interface)))~%~%" type-module)
  356.      (for-each
  357.          (lambda (type)
  358.              (unless (or (memq type define-only)
  359.                  (not (eq? type (base-type type))))
  360.                  (emit-type type (memq type read-only))))
  361.          types)
  362.      (close-port check)))
  363.  
  364.  
  365. ;;; Checking functions for procedure pointer types are emitted by the
  366. ;;; following procedure.  The arguments are the object type and the procedure
  367. ;;; to print the definitions.
  368.  
  369. (define (EMIT-CHK-PROCS type def-print)
  370.     (def-print `(define (,(uis "CHK-" (type-tag type)) x)
  371.             (if (and (pair? x) (eq? (car x) ',(type-tag type)))
  372.                 (cdr x)
  373.                 (error 
  374.                    "Argument is incorrect type: ~s" x))))
  375.     (def-print `(define (,(uis "ISA-" (type-tag type) "?") x)
  376.             (and (pair? x) (eq? (car x) ',(type-tag type))))))
  377.  
  378. ;;; Access functions for array types are generated by the following procedure.
  379. ;;; The arguments are the object type, a read-only flag, and the function to
  380. ;;; print the definitions.
  381.  
  382. (define (EMIT-ARRAY-PROCS pointer read-only def-print)
  383.     (let* ((type (pointer-to pointer))
  384.        (size (array-size type))
  385.        (entry-type (array-type type))
  386.        (chk (to-check-type pointer)))
  387.       (def-print `(define (,(uis type "-LENGTH") x)
  388.                   (fx/ (bytev-length (,chk x))
  389.                   ,(size-of entry-type))))
  390.       (cond ((or (isa-struct? entry-type) (isa-union? entry-type))
  391.          (def-print
  392.              `(define (,(uis type "->" entry-type "-LIST") x)
  393.                   (let* ((array (,chk x))
  394.                      (asize (bytev-length array))
  395.                      (esize ,(size-of entry-type)))
  396.                     (iterate loop ((x 0))
  397.                      (if (eq? x asize)
  398.                          '()
  399.                          (cons (cons ',(pointed-to-by
  400.                                    entry-type)
  401.                              (sub-bytev array
  402.                                  x (fx+ x esize)))
  403.                            (loop (fx+ x esize))))))))
  404.          (def-print
  405.              `(define (,(uis entry-type "-LIST->" type) x)
  406.                   (cons ',pointer
  407.                     (apply bytev-append
  408.                        (map ,(to-check-type
  409.                              (pointed-to-by
  410.                              entry-type))
  411.                         x))))))
  412.         (else
  413.          (def-print `(define (,type x i)
  414.                      (,(to-get-type type) (,chk x) 0 i)))
  415.          (def-print
  416.              `(define (,(uis type "->" entry-type "-LIST") x)
  417.                   (iterate loop ((i 0)
  418.                      (count (,(uis type "-LENGTH") x)))
  419.                    (if (eq? i count)
  420.                        '()
  421.                        (cons (,type x i)
  422.                          (loop (fx+ i 1) count))))))
  423.          (def-print
  424.              `(define (,(uis entry-type "-LIST->" type) l)
  425.                   (iterate loop ((l l)
  426.                      (i 0)
  427.                      (a (,(uis "MAKE-" type)
  428.                          ,@(if (eq? size 0)
  429.                            '((length l))
  430.                            '()))))
  431.                    (if l
  432.                        (begin (,(uis type "!") a i (car l))
  433.                           (loop (cdr l) (fx+ i 1) a))
  434.                        a))))
  435.          (def-print
  436.              `(define (,(uis type "!") x i z)
  437.                   (,(to-set!-type type) (,chk x) 0 i z)))
  438.          (def-print
  439.              `(define (,(uis "MAKE-" type)
  440.                    ,@(if (eq? size 0) '(x) '()))
  441.                   (cons ',pointer
  442.                     (make-bytev
  443.                     (fx* ,(size-of entry-type)
  444.                        ,(if (eq? size 0) 'x    size))))))))))
  445.  
  446. ;;; Write the source file containing the struct definition.  
  447.  
  448. (define (EMIT-STRUCT-PROCS pointer read-only type-file-root)
  449.     (let* ((type (pointer-to pointer))
  450.        (slots (uors-slots type)))
  451.       (if slots
  452.           (let* ((type-module (list->string
  453.                       (map char-downcase
  454.                        (string->list
  455.                            (symbol->string type)))))
  456.              (code-port (open-output-file
  457.                     (string-append type-module ".t"))))
  458.             
  459.             (define (DEF-PRINT exp)
  460.                 (pp exp code-port)
  461.                 (newline code-port))
  462.             
  463.             (format code-port 
  464.              "(herald ~a (env tsys (xlib interface)))~%" type-module)
  465.             (def-print `(define (,(uis "MAKE-" type))
  466.                     (cons ',pointer
  467.                           (make-bytev
  468.                           ,(fx* (fx/
  469.                               (fx+ (size-of type) 3)
  470.                               4)
  471.                               4)))))
  472.             (slot-getset type type 0 pointer read-only def-print)
  473.                 (close-port code-port)))))
  474.  
  475. ;;; Slot access functions for a structure are created by the following
  476. ;;; function.
  477.  
  478. (define (SLOT-GETSET type preamble offset base-type read-only def-print)
  479.     
  480.     (define (EMIT-PROCS type name offset)
  481.         (let ((index (if (isa-array? type) '(i) '())))
  482.          (def-print
  483.              `(define (,(uis preamble "-" name) x ,@index)
  484.                   (,(to-get-type type)
  485.                    (,(to-check-type base-type) x)
  486.                    ,offset
  487.                    ,@index)))
  488.          (unless read-only
  489.              (def-print
  490.                  `(define (,(uis preamble "-" name "!") x
  491.                        ,@index y)
  492.                       (,(to-set!-type type)
  493.                        (,(to-check-type base-type) x)
  494.                        ,offset
  495.                        ,@index
  496.                        y))))))
  497.     
  498.     (let loop ((slots (uors-slots type)) (offset offset))
  499.      (if slots
  500.          (let ((slot-type (caar slots))
  501.            (slot-name (cadar slots)))
  502.           (cond ((or (isa-union? slot-type) (isa-struct? slot-type))
  503.              (slot-getset slot-type
  504.                  (uis preamble "-" slot-name)
  505.                  offset base-type read-only def-print))
  506.             (else (emit-procs slot-type slot-name offset)))
  507.           (loop (cdr slots)
  508.             (if (isa-union? type)
  509.                 offset
  510.                 (+ offset (size-of slot-type))))))))
  511.